home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pascal / pascal_t.lha / pascal-s < prev   
Text File  |  1993-07-28  |  63KB  |  1,865 lines
  1. program pascals(input,  output);
  2.  
  3. { Author:  N. Wirth, E.T.H. CH-8092 Zurich, 1976
  4.   Debugged and Modified (for Prime):  June 1984
  5.   Modified (for Pyramid):  May 1986, Y.J. Choi, Flinders University
  6.                         (Australia)
  7. }
  8.  
  9. label 99;
  10. const
  11.       nkw = 27;                { no of key words }
  12.       alng = 10;               { no of significant chars in identifiers }
  13.       llng = 120;              { input line length }
  14.       emax = 322;              { max exponent of real numbers }
  15.       emin = -292;             { min exponent }
  16.       kmax = 15;               { max no. of significant digits }
  17.       tmax = 100;              { size of table }
  18.       bmax = 20;               { size of block-table }
  19.       amax = 30;               { size of array-table }
  20.       c2max = 20;              { size of real constant table}
  21.       csmax = 30;              { max no. of cases }
  22.       cmax = 850;              { size of code }
  23.       lmax = 7;                { maximum level }
  24.       smax = 600;              { size of string-table }
  25.       ermax = 58;              { max error no. }
  26.       omax = 63;               { highest order code }
  27.       xmax = 131071;           { 2**17 - 1 }
  28.       nmax = 2147483647;       { 2**31 - 1 }
  29.       lineleng = 136;          { output line length }
  30.       linelimit = 200;
  31.       stacksize = 1500;
  32.  
  33. type
  34.      symbol = ( intcon,realcon,charcon,string,
  35.                 notsy,plus,minus,times,idiv,rdiv,imod,andsy,orsy,
  36.                 eql,neq,gtr,geq,lss,leq,
  37.                 lparent,rparent,lbrack,rbrack,comma,semicolon,period,
  38.                 colon,becomes,constsy,typesy,varsy,functionsy,
  39.                 proceduresy,arraysy,recordsy,programsy,ident,
  40.                 beginsy,ifsy,casesy,repeatsy,whilesy,forsy,
  41.                 endsy,elsesy,untilsy,ofsy,dosy,tosy,downtosy,thensy);
  42.  
  43.       index = -xmax .. +xmax;
  44.       alfa = packed array [1..alng] of char;
  45.       object = (konstant,variable,type1,prozedure,funktion);
  46.       types = (notyp,ints,reals,bools,chars,arrays,records);
  47.       symset = set of symbol;
  48.       typset = set of types;
  49.       item = record
  50.                typ: types; ref: index;
  51.              end ;
  52.       order = packed record
  53.                 f: -omax..+omax;
  54.                 x: -lmax..+lmax;
  55.                 y: -nmax..+nmax;
  56.               end ;
  57.  
  58. var
  59.     lno: integer;
  60.     sy: symbol;              { last symbol read by insymbol }
  61.     id: alfa;                { identifier from insymbol }
  62.     inum: integer;           { integer from insymbol }
  63.     rnum: real;              { real number from insymbol }
  64.     sleng: integer;          { string length }
  65.     ch: char;                { last character read from source program }
  66.     line: array [1..llng] of char;
  67.     cc: integer;             { character counter }
  68.     lc: integer;             { progrm location counter }
  69.     ll: integer;             { length of current line }
  70.     errs: set of 0..ermax;
  71.     errpos: integer;
  72.     progname: alfa;
  73.     constbegsys,typebegsys,blockbegsys,facbegsys,statbegsys: symset;
  74.     key: array [1..nkw] of alfa;
  75.     ksy: array [1..nkw] of symbol;
  76.     sps: array [char] of symbol;   { special symbols }
  77.  
  78.     t,a,b,sx,c1,c2: integer;   { indices to tables }
  79.     stantyps: typset;
  80.     display: array [0 .. lmax] of integer;
  81.  
  82.     tab:    array [0 .. tmax] of    { identifier table }
  83.               packed record
  84.                 name: alfa;  link: index;
  85.                 obj: object; typ: types;
  86.                 ref: index;  normal: boolean;
  87.                 lev: 0 .. lmax; adr: integer;
  88.               end ;
  89.     atab:   array [1 .. amax] of       { array-table }
  90.               packed record
  91.                 inxtyp, eltyp: types;
  92.                 elref, low, high, elsize, size: index;
  93.               end ;
  94.     btab:   array [1 .. bmax] of     { block-table }
  95.               packed record
  96.                  last, lastpar, psize, vsize: index
  97.               end ;
  98.     stab:   packed array [0..smax] of char;     { string table }
  99.     rconst: array [1 .. c2max] of real;
  100.     code:   array [0 .. cmax] of order;
  101.  
  102. (*
  103. procedure readfilename(var f:alfa);
  104. var ch: char; i: integer;
  105. begin
  106.     i := 0;
  107.     if eoln then f := '/dev/tty  '
  108.     else
  109.     begin f := '';
  110.          while not eoln do
  111.          begin read(ch);
  112.                i := i + 1;
  113.                if i <= 10 then f[i] := ch
  114.          end;
  115.     end
  116. end;
  117. *)
  118.  
  119. procedure initialise;
  120. begin
  121.    key[ 1] := 'and       '; key[ 2] := 'array     ';
  122.    key[ 3] := 'begin     '; key[ 4] := 'case      ';
  123.    key[ 5] := 'const     '; key[ 6] := 'div       ';
  124.    key[ 7] := 'do        '; key[ 8] := 'downto    ';
  125.    key[ 9] := 'else      '; key[10] := 'end       ';
  126.    key[11] := 'for       '; key[12] := 'function  ';
  127.    key[13] := 'if        '; key[14] := 'mod       ';
  128.    key[15] := 'not       '; key[16] := 'of        ';
  129.    key[17] := 'or        '; key[18] := 'procedure ';
  130.    key[19] := 'program   '; key[20] := 'record    ';
  131.    key[21] := 'repeat    '; key[22] := 'then      ';
  132.    key[23] := 'to        '; key[24] := 'type      ';
  133.    key[25] := 'until     '; key[26] := 'var       ';
  134.    key[27] := 'while     ';
  135.    ksy[ 1] := andsy;        ksy[ 2] := arraysy;
  136.    ksy[ 3] := beginsy;      ksy[ 4] := casesy;
  137.    ksy[ 5] := constsy;      ksy[ 6] := idiv;
  138.    ksy[ 7] := dosy;         ksy[ 8] := downtosy;
  139.    ksy[ 9] := elsesy;       ksy[10] := endsy;
  140.    ksy[11] := forsy;        ksy[12] := functionsy;
  141.    ksy[13] := ifsy;         ksy[14] := imod;
  142.    ksy[15] := notsy;        ksy[16] := ofsy;
  143.    ksy[17] := orsy;         ksy[18] := proceduresy;
  144.    ksy[19] := programsy;    ksy[20] := recordsy;
  145.    ksy[21] := repeatsy;     ksy[22] := thensy;
  146.    ksy[23] := tosy;         ksy[24] := typesy;
  147.    ksy[25] := untilsy;      ksy[26] := varsy;
  148.    ksy[27] := whilesy;
  149.    sps['+'] := plus;        sps['-'] := minus;
  150.    sps['*'] := times;       sps['/'] := rdiv;
  151.    sps['('] := lparent;     sps[')'] := rparent;
  152.    sps['='] := eql;         sps[','] := comma;
  153.    sps['['] := lbrack;      sps[']'] := rbrack;
  154.    sps['#'] := neq;         sps['f'] := andsy;
  155.    sps[';'] := semicolon;
  156.  
  157.   constbegsys := [plus,minus,intcon,realcon,charcon,ident];
  158.   typebegsys := [ident,arraysy,recordsy];
  159.   blockbegsys := [constsy,typesy,varsy,proceduresy,
  160.                   functionsy,beginsy];
  161.   facbegsys := [intcon,realcon,charcon,ident,lparent,notsy];
  162.   statbegsys := [beginsy,ifsy,whilesy,repeatsy,forsy,casesy];
  163.   stantyps := [notyp,ints,reals,bools,chars];
  164.  
  165.   lc := 0; ll := 0; cc := 0; ch := ' '; lno := 0;
  166.   errpos := 0; errs := [];
  167.   t := -1; a := 0; b := 1; sx := 0; c2 := 0;
  168.   display[0] := 1;
  169. end;  {initialise}
  170.  
  171. procedure errormsg;
  172.    var k: integer;
  173.        msg: array [0..ermax] of alfa;
  174. begin
  175.   msg[ 0] := 'undef id  '; msg[ 1] := 'multi def ';
  176.   msg[ 2] := 'identifier'; msg[ 3] := 'program   ';
  177.   msg[ 4] := ')         '; msg[ 5] := ':         ';
  178.   msg[ 6] := 'syntax    '; msg[ 7] := 'ident, var';
  179.   msg[ 8] := 'of        '; msg[ 9] := '(         ';
  180.   msg[10] := 'id, array '; msg[11] := '[         ';
  181.   msg[12] := ']         '; msg[13] := '..        ';
  182.   msg[14] := ':         '; msg[15] := 'func. type';
  183.   msg[16] := '=         '; msg[17] := 'boolean   ';
  184.   msg[18] := 'convar typ'; msg[19] := 'type      ';
  185.   msg[20] := 'prog.param'; msg[21] := 'too big   ';
  186.   msg[22] := '.         '; msg[23] := 'typ (case)';
  187.   msg[24] := 'character '; msg[25] := 'const id  ';
  188.   msg[26] := 'index type'; msg[27] := 'indexbound';
  189.   msg[28] := 'no array  '; msg[29] := 'type id   ';
  190.   msg[30] := 'undef type'; msg[31] := 'no record ';
  191.   msg[32] := 'boole type'; msg[33] := 'arith type';
  192.   msg[34] := 'integer   '; msg[35] := 'types     ';
  193.   msg[36] := 'param type'; msg[37] := 'variab id ';
  194.   msg[38] := 'string    '; msg[39] := 'no.of pars';
  195.   msg[40] := 'type      '; msg[41] := 'type      ';
  196.   msg[42] := 'real type '; msg[43] := 'integer   ';
  197.   msg[44] := 'var, const'; msg[45] := 'var, proc ';
  198.   msg[46] := 'types (:=)'; msg[47] := 'typ (case)';
  199.   msg[48] := 'type      '; msg[49] := 'store ovfl';
  200.   msg[50] := 'constant  '; msg[51] := ':=        ';
  201.   msg[52] := 'then      '; msg[53] := 'until     ';
  202.   msg[54] := 'do        '; msg[55] := 'to downto ';
  203.   msg[56] := 'begin     '; msg[57] := 'end       ';
  204.   msg[58] := 'factor    ';
  205.   k := 0; writeln(output); writeln(output,' key words');
  206.   while errs <> [] do
  207.   begin while not (k in errs) do k := k+1;
  208.         writeln(output,k,'  ',msg[k]); errs := errs - [k]
  209.   end
  210. end   { errormsg } ;
  211.  
  212. procedure error(n: integer);
  213. begin if errpos = 0 then write(output,' ****     ');
  214.    if cc > errpos then
  215.       begin write(output,' ': cc-errpos, '^', n:2);
  216.          errpos := cc+3; errs := errs + [n]
  217.       end
  218. end { error } ;
  219.  
  220. procedure fatal(n: integer);
  221.    var msg: array [1..7] of alfa;
  222. begin writeln; errormsg;
  223.    msg[ 1] := 'identifier'; msg[ 2] := 'procedures';
  224.    msg[ 3] := 'reals     '; msg[ 4] := 'arrays    ';
  225.    msg[ 5] := 'levels    '; msg[ 6] := 'code      ';
  226.    msg[ 7] := 'strings   ';
  227.    writeln(output,' compiler table for ', msg[n], ' is too small');
  228.    goto 99    { terminate compilation }
  229. end  { fatal } ;
  230.  
  231. procedure nextch;   { read next character; process line end }
  232. begin if cc = ll then
  233.       begin if eof(input) then
  234.             begin writeln(output);
  235.                writeln(output,' program incomplete');
  236.                errormsg; goto 99
  237.             end ;
  238.          if errpos <> 0 then
  239.             begin writeln(output); errpos := 0
  240.             end ;
  241.          lno := lno+1;
  242.          write(output, lno:5, lc:5, ' ');
  243.          ll := 0; cc := 0;
  244.          while not eoln(input) do
  245.             begin ll := ll+1; read(input,ch); write(output,ch);
  246.                   line[ll] := ch
  247.             end ;
  248.          writeln(output); ll := ll+1; read(input,line[ll])
  249.       end ;
  250.    cc := cc+1; ch := line[cc];
  251. end { nextch } ;
  252.  
  253. procedure insymbol;         { reads next symbol }
  254.    label 1,2,3;
  255.    var i,j,k,e: integer;
  256.  
  257.    procedure readscale;
  258.       var s, sign: integer;
  259.    begin nextch; sign := 1; s := 0;
  260.       if ch = '+' then nextch else
  261.       if ch = '-' then begin nextch; sign := -1 end ;
  262.       while ch in ['0'..'9'] do
  263.          begin s := 10*s + ord(ch) - ord('0'); nextch
  264.          end ;
  265.       e := s*sign + e
  266.    end  { readscale } ;
  267.  
  268.    procedure adjustscale;
  269.       var s: integer; d,t: real;
  270.    begin if k+e > emax then error(21) else
  271.          if k+e < emin then rnum := 0 else
  272.      begin s := abs(e); t := 1.0; d := 10.0;
  273.        repeat
  274.          while not odd(s) do
  275.             begin s := s div 2; d := sqr(d)
  276.             end ;
  277.          s := s-1; t := d*t
  278.        until s = 0;
  279.      if e >= 0 then rnum := rnum*t else rnum := rnum/t
  280.    end
  281.  end  { adjustscale } ;
  282.  
  283. begin { insymbol }
  284. 1: while ch = ' ' do nextch;
  285.    if ch in ['a'..'z','A'..'Z'] then
  286.    begin { word }  k := 0; id := '          ';
  287.       repeat if k < alng then
  288.              begin
  289.                if ch in ['A'..'Z'] then   { convert to lower case }
  290.                   ch := chr(ord('a')+ord(ch)-ord('A'));
  291.                k := k+1; id[k] := ch
  292.              end ;
  293.          nextch
  294.       until not (ch in ['a'..'z','A'..'Z','_','0'..'9']);
  295.       i := 1; j := nkw;    { binary search }
  296.       repeat k := (i+j) div 2;
  297.          if id <= key[k] then j := k-1;
  298.          if id >= key[k] then i := k+1
  299.       until i > j;
  300.       if i-1 > j then sy := ksy[k] else sy := ident
  301.    end else
  302.    if ch in ['0'..'9'] then
  303.    begin { number } k := 0; inum := 0; sy := intcon;
  304.       repeat inum := inum*10 + ord(ch) - ord('0');
  305.          k := k+1; nextch
  306.       until not (ch in ['0'..'9']);
  307.       if (k > kmax) or (inum > nmax) then
  308.         begin error(21); inum := 0; k := 0
  309.         end ;
  310.       if ch = '.' then
  311.       begin nextch;
  312.          if ch = '.' then ch := ':' else
  313.             begin sy := realcon; rnum := inum; e := 0;
  314.                while ch in ['0'..'9'] do
  315.                begin e := e-1;
  316.                   rnum := 10.0*rnum + (ord(ch)-ord('0')); nextch
  317.                end ;
  318.                if ch = 'e' then readscale;
  319.                if e <> 0 then adjustscale
  320.             end
  321.       end else
  322.       if ch = 'e' then
  323.       begin sy := realcon; rnum := inum; e := 0;
  324.          readscale; if e <> 0 then adjustscale
  325.       end ;
  326.    end else
  327.    case ch of
  328. ':' : begin nextch;
  329.           if ch = '=' then
  330.             begin sy := becomes; nextch
  331.             end  else sy := colon
  332.       end ;
  333. '<' : begin nextch;
  334.          if ch = '=' then begin sy := leq; nextch end else
  335.          if ch = '>' then begin sy := neq; nextch end else sy := lss
  336.       end ;
  337. '>' : begin nextch;
  338.          if ch = '=' then begin sy := geq; nextch end else sy := gtr
  339.       end ;
  340. '.' : begin nextch;
  341.          if ch = '.' then
  342.             begin sy := colon; nextch
  343.             end  else sy := period
  344.       end ;
  345. '''': begin k := 0;
  346.     2:  nextch;
  347.         if ch = '''' then
  348.           begin nextch; if ch <> '''' then goto 3
  349.           end ;
  350.         if sx+k = smax then fatal(7);
  351.         stab[sx+k] := ch; k := k+1;
  352.         if cc = 1 then
  353.           begin  { end of line } k := 0;
  354.           end
  355.         else goto 2;
  356.     3:  if k = 1 then
  357.            begin sy := charcon; inum := ord(stab[sx])
  358.            end else
  359.         if k = 0 then
  360.            begin error(38); sy := charcon; inum := 0
  361.            end else
  362.            begin sy := string; inum := sx; sleng := k; sx := sx+k
  363.            end
  364.       end ;
  365. '(' : begin nextch;
  366.          if ch <> '*' then sy := lparent else
  367.          begin { comment } nextch;
  368.             repeat
  369.                while ch <> '*' do nextch;
  370.                nextch
  371.             until ch = ')';
  372.             nextch; goto 1
  373.          end
  374.       end ;
  375. '{' : begin {comment} nextch;
  376.          repeat
  377.             nextch
  378.          until ch = '}';
  379.          nextch; goto 1
  380.       end;
  381.  
  382. '+', '=', '-', '*', '/', ')',  ',', '[', ']', ';', '#', 'f' :
  383.       begin sy := sps[ch]; nextch
  384.       end ;
  385. otherwise
  386.       begin error(24); nextch; goto 1
  387.       end
  388.    end
  389. end   { insymbol } ;
  390.  
  391. procedure enter(x0: alfa; x1: object;
  392.                 x2: types; x3: integer);
  393. begin t := t+1;   { enter standard identifier }
  394.    with tab[t] do
  395.    begin name := x0; link := t-1; obj := x1;
  396.       typ := x2; ref := 0; normal := true;
  397.       lev := 0; adr := x3
  398.    end
  399. end   { enter } ;
  400.  
  401. procedure enterarray(tp: types; l,h: integer);
  402. begin if l > h then error(27);
  403.    if (abs(l)>xmax) or (abs(h)>xmax) then
  404.       begin error(27); l := 0; h := 0;
  405.       end ;
  406.    if a = amax then fatal(4) else
  407.       begin a := a+1;
  408.         with atab[a] do
  409.             begin inxtyp := tp; low := l; high := h
  410.             end
  411.       end
  412. end  { enterarray } ;
  413.  
  414. procedure enterblock;
  415. begin if b = bmax then fatal(2) else
  416.       begin b := b+1; btab[b].last := 0; btab[b].lastpar := 0
  417.       end
  418. end  { enterblock } ;
  419.  
  420. procedure enterreal(x: real);
  421. begin if c2 = c2max-1 then fatal(3) else
  422.       begin rconst[c2+1] := x; c1 := 1;
  423.          while rconst[c1] <> x do c1 := c1+1;
  424.          if c1 > c2 then c2 := c1
  425.       end
  426. end  { enterreal } ;
  427.  
  428. procedure init_symboltable;
  429. begin
  430.   enter('          ', variable, notyp, 0);  { sentinel }
  431.   enter('false     ', konstant, bools, 0);
  432.   enter('true      ', konstant, bools, 1);
  433.   enter('real      ', type1, reals, 1);
  434.   enter('char      ', type1, chars, 1);
  435.   enter('boolean   ', type1, bools, 1);
  436.   enter('integer   ', type1, ints,  1);
  437.   enter('abs       ', funktion, reals,0);
  438.   enter('sqr       ', funktion, reals,2);
  439.   enter('odd       ', funktion, bools,4);
  440.   enter('chr       ', funktion, chars,5);
  441.   enter('ord       ', funktion, ints, 6);
  442.   enter('succ      ', funktion, chars,7);
  443.   enter('pred      ', funktion, chars,8);
  444.   enter('round     ', funktion, ints, 9);
  445.   enter('trunc     ', funktion, ints, 10);
  446.   enter('sin       ', funktion, reals, 11);
  447.   enter('cos       ', funktion, reals, 12);
  448.   enter('exp       ', funktion, reals, 13);
  449.   enter('ln        ', funktion, reals, 14);
  450.   enter('sqrt      ', funktion, reals, 15);
  451.   enter('arctan    ', funktion, reals, 16);
  452.   enter('eof       ', funktion, bools, 17);
  453.   enter('eoln      ', funktion, bools, 18);
  454.   enter('read      ', prozedure, notyp, 1);
  455.   enter('readln    ', prozedure, notyp, 2);
  456.   enter('write     ', prozedure, notyp, 3);
  457.   enter('writeln   ', prozedure, notyp, 4);
  458.   enter(progname,     prozedure, notyp, 0);
  459. end; { init_symboltable }
  460.  
  461. procedure emit(fct: integer);
  462. begin if lc = cmax then fatal(6);
  463.    code[lc].f := fct; lc := lc+1
  464. end  { emit } ;
  465.  
  466. procedure emit1(fct,b: integer);
  467. begin if lc = cmax then fatal(6);
  468.    with code[lc] do
  469.       begin f := fct; y := b end ;
  470.    lc := lc+1
  471. end  { emit1 } ;
  472.  
  473. procedure emit2(fct,a,b: integer);
  474. begin if lc = cmax then fatal(6);
  475.    with code[lc] do
  476.       begin f := fct; x := a; y := b end ;
  477.    lc := lc+1
  478. end  { emit2 } ;
  479.  
  480. procedure printtables;
  481.    var i: integer; o: order;
  482. begin
  483.    writeln(output);
  484.    writeln(output,'identifiers          link  obj  typ  ref  nrm  lev  adr');
  485.    for i := 1 to btab[1].last do
  486.       with tab[i] do
  487.       writeln(output,i,' ',name,link:5, ord(obj):5, ord(typ):5, ref:5,
  488.             ord(normal):5, lev:5, adr:5);
  489.    writeln('       ..............................................');
  490.    for i := btab[1].last + 1 to t do
  491.       with tab[i] do
  492.       writeln(output,i,' ',name,link:5, ord(obj):5, ord(typ):5, ref:5,
  493.             ord(normal):5, lev:5, adr:5);
  494.    writeln(output);
  495.    writeln(output,'blocks    last lpar psze vsze');
  496.    for i := 1 to b do
  497.       with btab[i] do
  498.       writeln(output,i, last:5, lastpar:5, psize:5, vsize:5);
  499.    writeln(output);
  500.    writeln(output,'arrays    xtyp etyp eref  low high elsz size');
  501.    for i := 1 to a do
  502.       with atab[i] do
  503.       writeln(output,i, ord(inxtyp):5, ord(eltyp):5,
  504.               elref:5, low:5, high:5, elsize:5, size:5);
  505.    writeln(output);
  506.    writeln(output,'string');
  507.    for i :=0 to sx-1 do write(output,stab[i]);
  508.    writeln(output);
  509.    writeln(output,'code:');
  510.    for i := 0 to lc-1 do
  511.    begin if i mod 5 = 0 then
  512.          begin writeln(output); write(output,i:5)
  513.          end ;
  514.       o := code[i]; write(output,o.f:5);
  515.       if o.f < 31 then
  516.         if o.f < 4 then write(output,o.x:2, o.y:5)
  517.                     else write(output,o.y:7)
  518.       else write(output,'       ');
  519.       write(output,',')
  520.    end ;
  521.    writeln(output);  writeln(output)
  522. end  { printtables } ;
  523.  
  524.  
  525. procedure block(fsys: symset; isfun: boolean; level: integer);
  526.    type conrec =
  527.       record case tp: types of
  528.          ints,chars,bools: (i: integer);
  529.          reals: (r: real)
  530.       end ;
  531.  
  532.    var dx: integer;   { data allocation index }
  533.        prt: integer;  { t-index of this procedure }
  534.        prb: integer;  { b-index of this procedure }
  535.        x: integer;
  536.  
  537.    procedure skip(fsys: symset; n: integer);
  538.    begin error(n);
  539.       while not (sy in fsys) do insymbol
  540.    end  { skip } ;
  541.  
  542. procedure test(s1,s2: symset; n: integer);
  543. begin if not (sy in s1) then
  544.       skip(s1+s2,n)
  545. end  { test } ;
  546. procedure testsemicolon;
  547. begin
  548.   if sy = semicolon then insymbol else
  549.   begin error(14);
  550.     if sy in [comma,colon] then insymbol
  551.   end ;
  552.   test([ident]+blockbegsys, fsys, 6)
  553. end  { testsemicolon } ;
  554.  
  555. procedure enter(id: alfa; k: object);
  556.    var j,l: integer;
  557. begin if t = tmax then fatal(1) else
  558.       begin tab[0].name := id;
  559.          j := btab[display[level]].last;  l := j;
  560.          while tab[j].name <> id do j := tab[j].link;
  561.          if j <> 0 then error(1) else
  562.          begin t := t+1;
  563.            with tab[t] do
  564.            begin name := id; link := l;
  565.             obj := k; typ := notyp; ref := 0; lev := level;
  566.             adr := 0
  567.            end ;
  568.            btab[display[level]].last := t
  569.          end
  570.       end
  571. end  { enter } ;
  572.  
  573. function loc(id: alfa): integer;
  574.    var i,j: integer;      { locate id in table }
  575. begin i := level; tab[0].name := id;   { sentinel }
  576.    repeat j := btab[display[i]].last;
  577.       while tab[j].name <> id do
  578.       begin
  579.         j := tab[j].link;
  580.       end;
  581.       i := i-1;
  582.    until (i<0) or (j<>0);
  583.    if j = 0 then error(0);  loc := j
  584. end  { loc } ;
  585.  
  586. procedure entervariable;
  587. begin if sy = ident then
  588.         begin enter(id,variable); insymbol
  589.         end
  590.       else error(2)
  591. end  { entervariable } ;
  592.  
  593. procedure constant(fsys: symset; var c: conrec);
  594.   var x, sign: integer;
  595. begin c.tp := notyp; c.i := 0;
  596. test(constbegsys, fsys, 50);
  597. if sy in constbegsys then
  598. begin
  599.     if sy = charcon then
  600.       begin c.tp := chars; c.i := inum; insymbol
  601.       end
  602.     else
  603.       begin sign := 1;
  604.         if sy in [plus,minus] then
  605.           begin if sy = minus then sign := -1;
  606.             insymbol
  607.           end ;
  608.         if sy = ident then
  609.           begin x := loc(id);
  610.             if x <> 0 then
  611.               if tab[x].obj <> konstant then error(25) else
  612.               begin c.tp := tab[x].typ;
  613.                 if c.tp = reals
  614.                      then c.r := sign*rconst[tab[x].adr]
  615.                      else c.i := sign*tab[x].adr
  616.               end;
  617.             insymbol
  618.           end
  619.         else
  620.         if sy = intcon then
  621.            begin c.tp := ints; c.i := sign*inum; insymbol
  622.            end else
  623.         if sy = realcon then
  624.            begin c.tp := reals; c.r := sign*rnum; insymbol
  625.            end else skip(fsys,50)
  626.       end;
  627.     test(fsys, [], 6)
  628.   end
  629. end  { constant } ;
  630.  
  631. procedure typ(fsys: symset; var tp: types; var rf, sz: integer);
  632.   var x: integer;
  633.       eltp: types; elrf: integer;
  634.       elsz, offset, t0,t1: integer;
  635.  
  636. procedure arraytyp(var aref,arsz: integer);
  637.    var eltp: types;
  638.       low, high: conrec;
  639.       elrf, elsz: integer;
  640. begin constant([colon,rbrack,rparent,ofsy]+fsys, low);
  641.    if low.tp = reals then
  642.       begin error(27); low.tp := ints; low.i := 0
  643.       end;
  644.    if sy = colon then insymbol else error(13);
  645.    constant([rbrack,comma,rparent,ofsy]+fsys, high);
  646.    if high.tp <> low.tp then
  647.       begin error(27); high.i := low.i
  648.       end ;
  649.  
  650.    enterarray(low.tp, low.i, high.i); aref := a;
  651.    if sy = comma then
  652.       begin insymbol; eltp := arrays; arraytyp(elrf,elsz)
  653.       end else
  654.    begin
  655.       if sy = rbrack then insymbol else
  656.          begin error(12);
  657.             if sy = rparent then insymbol
  658.          end ;
  659.       if sy = ofsy then insymbol else error(8);
  660.       typ(fsys,eltp,elrf,elsz)
  661.    end ;
  662.    with atab[aref] do
  663.    begin arsz := (high-low+1)*elsz; size := arsz;
  664.       eltyp := eltp; elref := elrf; elsize := elsz
  665.    end ;
  666. end  { arraytyp } ;
  667.  
  668. begin { typ } tp := notyp; rf := 0; sz := 0;
  669.   test(typebegsys, fsys, 10);
  670.   if sy in typebegsys then
  671.     begin
  672.       if sy = ident then
  673.       begin x := loc(id);
  674.         if x <> 0 then
  675.         with tab[x] do
  676.           if obj <> type1 then error(29) else
  677.           begin tp := typ; rf := ref; sz := adr;
  678.             if tp = notyp then error(30)
  679.           end ;
  680.         insymbol
  681.       end else
  682.       if sy = arraysy then
  683.       begin insymbol;
  684.           if sy = lbrack then insymbol else
  685.              begin error(11);
  686.                 if sy = lparent then insymbol
  687.              end ;
  688.           tp := arrays; arraytyp(rf,sz)
  689.       end else
  690.       begin { records } insymbol;
  691.         enterblock; tp := records; rf := b;
  692.         if level = lmax then fatal(5);
  693.         level := level+1; display[level] := b; offset := 0;
  694.         while sy <> endsy do
  695.         begin  { field section }
  696.           if sy = ident then
  697.           begin t0 := t; entervariable;
  698.             while sy = comma do
  699.               begin insymbol; entervariable
  700.               end ;
  701.             if sy = colon then insymbol else error(5);
  702.             t1 := t;
  703.             typ(fsys+[semicolon,endsy,comma,ident],
  704.                 eltp,elrf,elsz);
  705.             while t0 < t1 do
  706.             begin t0 := t0+1;
  707.               with tab[t0] do
  708.               begin typ := eltp; ref := elrf; normal := true;
  709.                 adr := offset; offset := offset + elsz
  710.               end
  711.             end
  712.           end ;
  713.           if sy <> endsy then
  714.           begin if sy = semicolon then insymbol else
  715.                 begin error(14);
  716.                   if sy = comma then insymbol
  717.                 end ;
  718.              test([ident,endsy,semicolon], fsys, 6)
  719.           end
  720.         end ;
  721.         btab[rf].vsize := offset; sz := offset;
  722.         btab[rf].psize := 0; insymbol; level := level-1
  723.       end ;
  724.       test(fsys, [], 6)
  725.     end
  726. end  { typ } ;
  727.  
  728. procedure parameterlist;    { formal parameter list }
  729.    var tp: types;
  730.        rf, sz, x, t0: integer;
  731.        valpar: boolean;
  732. begin insymbol; tp := notyp; rf := 0; sz := 0;
  733.   test([ident, varsy], fsys+[rparent], 7);
  734.   while sy in [ident,varsy] do
  735.     begin if sy <> varsy then valpar := true else
  736.             begin insymbol; valpar := false
  737.             end ;
  738.       t0 := t; entervariable;
  739.       while sy = comma do
  740.          begin insymbol; entervariable;
  741.          end ;
  742.       if sy = colon then
  743.         begin insymbol;
  744.           if sy <> ident then error(2) else
  745.           begin x := loc(id); insymbol;
  746.             if x <> 0 then
  747.             with tab[x] do
  748.               if obj <> type1 then error(29) else
  749.                 begin tp := typ; rf := ref;
  750.                   if valpar then sz := adr else sz := 1
  751.                 end ;
  752.           end ;
  753.           test([semicolon,rparent], [comma,ident]+fsys, 14)
  754.         end
  755.       else error(5);
  756.       while t0 < t do
  757.       begin t0 := t0+1;
  758.         with tab[t0] do
  759.         begin typ := tp; ref := rf;
  760.             normal := valpar; adr := dx; lev := level;
  761.             dx := dx + sz
  762.         end
  763.       end ;
  764.       if sy <> rparent then
  765.       begin if sy = semicolon then insymbol else
  766.             begin error(14);
  767.               if sy = comma then insymbol
  768.             end ;
  769.          test([ident,varsy], [rparent]+fsys, 6)
  770.       end
  771.     end  { while } ;
  772.   if sy = rparent then
  773.     begin insymbol;
  774.       test([semicolon,colon], fsys, 6)
  775.     end
  776.   else error(4)
  777. end  { parameterlist } ;
  778.  
  779. procedure constantdeclaration;
  780.   var c: conrec;
  781. begin insymbol;
  782.   test([ident], blockbegsys, 2);
  783.   while sy = ident do
  784.     begin enter(id,konstant); insymbol;
  785.       if sy = eql then insymbol else
  786.          begin error(16);
  787.             if sy = becomes then insymbol
  788.          end ;
  789.       constant([semicolon,comma,ident]+fsys,c);
  790.       tab[t].typ := c.tp; tab[t].ref := 0;
  791.       if c.tp = reals then
  792.         begin enterreal(c.r); tab[t].adr := c1 end
  793.       else tab[t].adr := c.i;
  794.       testsemicolon
  795.     end
  796. end  { constantdeclaration } ;
  797.  
  798. procedure typedeclaration;
  799.   var tp: types; rf, sz, t1: integer;
  800. begin insymbol;
  801.   test([ident], blockbegsys, 2);
  802.   while sy = ident do
  803.     begin enter(id,type1); t1 := t; insymbol;
  804.       if sy = eql then insymbol else
  805.          begin error(16);
  806.             if sy = becomes then insymbol
  807.          end ;
  808.       typ([semicolon,comma,ident]+fsys, tp, rf, sz);
  809.       with tab[t1] do
  810.         begin typ := tp; ref := rf; adr := sz
  811.         end ;
  812.       testsemicolon
  813.     end
  814. end  { typedeclaration } ;
  815.  
  816. procedure variabledeclaration;
  817.   var t0, t1, rf, sz: integer;
  818.       tp: types;
  819. begin insymbol;
  820.   while sy = ident do
  821.   begin t0 := t; entervariable;
  822.     while sy = comma do
  823.       begin insymbol; entervariable;
  824.       end ;
  825.     if sy = colon then insymbol else error(5);
  826.     t1 := t;
  827.     typ([semicolon,comma,ident]+fsys, tp, rf, sz);
  828.     while t0 < t1 do
  829.     begin t0 := t0+1;
  830.       with tab[t0] do
  831.       begin typ := tp; ref := rf;
  832.         lev := level; adr := dx; normal := true;
  833.         dx := dx + sz
  834.       end
  835.     end ;
  836.     testsemicolon
  837.   end
  838. end  { variabledeclaration } ;
  839.  
  840. procedure procdeclaration;
  841.    var isfun: boolean;
  842. begin isfun := sy = functionsy; insymbol;
  843.   if sy <> ident then
  844.      begin  error(2); id := '          '
  845.      end ;
  846.   if isfun then enter(id,funktion) else enter(id,prozedure);
  847.   tab[t].normal := true;
  848.   insymbol; block([semicolon]+fsys, isfun, level+1);
  849.   if sy = semicolon then insymbol else error(14);
  850.   emit(32+ord(isfun))     { exit }
  851. end   { proceduredeclaration } ;
  852.  
  853.  
  854. procedure statement(fsys: symset);
  855.    var i: integer; x: item;
  856.    procedure expression(fsys: symset; var x: item); forward;
  857.  
  858.    procedure selector(fsys: symset; var v:item);
  859.       var x: item; a,j: integer;
  860.    begin  { sy in [lparent, lbrack, period] }
  861.    repeat
  862.      if sy = period then
  863.      begin insymbol;  { field selector }
  864.        if sy <> ident then error(2) else
  865.        begin
  866.          if v.typ <> records then error(31) else
  867.          begin { search field identifier }
  868.            j := btab[v.ref].last; tab[0].name := id;
  869.            while tab[j].name <> id do j := tab[j].link;
  870.            if j = 0 then error(0);
  871.            v.typ := tab[j].typ; v.ref := tab[j].ref;
  872.            a := tab[j].adr; if a <> 0 then emit1(9,a)
  873.          end ;
  874.          insymbol
  875.        end
  876.      end else
  877.      begin  { array selector }
  878.        if sy <> lbrack then error(11);
  879.        repeat insymbol;
  880.          expression(fsys+[comma,rbrack], x);
  881.          if v.typ <> arrays then error(28) else
  882.            begin a := v.ref;
  883.              if atab[a].inxtyp <> x.typ then error(26) else
  884.            if atab[a].elsize = 1 then emit1(20,a)
  885.                                  else emit1(21,a);
  886.              v.typ := atab[a].eltyp; v.ref := atab[a].elref
  887.            end
  888.        until sy <> comma;
  889.        if sy = rbrack then insymbol else
  890.          begin error(12); if sy = rparent then insymbol
  891.          end
  892.      end
  893.    until not (sy in [lbrack,lparent,period]);
  894.    test(fsys, [], 6)
  895. end  { selector } ;
  896.  
  897. procedure call(fsys: symset; i: integer);
  898.    var x: item;
  899.        lastp, cp, k: integer;
  900. begin
  901.   emit1(18,i);  { mark stack }
  902.   lastp := btab[tab[i].ref].lastpar; cp := i;
  903.   if sy = lparent then
  904.   begin  { actual parameter list }
  905.     repeat insymbol;
  906.       if cp >= lastp then error(39) else
  907.       begin cp := cp+1;
  908.         if tab[cp].normal then
  909.         begin  { value parameter }
  910.           expression(fsys+[comma,colon,rparent], x);
  911.           if x.typ=tab[cp].typ then
  912.             begin
  913.               if x.ref <> tab[cp].ref then error(36) else
  914.         if x.typ = arrays then emit1(22,atab[x.ref].size) else
  915.               if x.typ = records then emit1(22,btab[x.ref].vsize)
  916.  
  917.                end else
  918.              if (x.typ=ints) and (tab[cp].typ=reals) then
  919.                 emit1(26,0) else
  920.                 if x.typ<>notyp then error(36);
  921.            end else
  922.            begin  { variable parameter }
  923.              if sy <> ident then error(2) else
  924.              begin k := loc(id); insymbol;
  925.                if k <> 0 then
  926.                begin if tab[k].obj <> variable then error(37);
  927.                  x.typ := tab[k].typ; x.ref := tab[k].ref;
  928.                  if tab[k].normal
  929.                     then emit2(0,tab[k].lev,tab[k].adr)
  930.                     else emit2(1,tab[k].lev,tab[k].adr);
  931.                  if sy in [lbrack,lparent,period] then
  932.                     selector(fsys+[comma,colon,rparent], x);
  933.                  if (x.typ<>tab[cp].typ) or (x.ref<>tab[cp].ref)
  934.                  then error(36)
  935.                end
  936.              end
  937.            end
  938.          end ;
  939.          test([comma,rparent], fsys, 6)
  940.        until sy <> comma;
  941.        if sy = rparent then insymbol else error(4)
  942.      end ;
  943.      if cp < lastp then error(39);  { too few actual parameters }
  944.      emit1(19, btab[tab[i].ref].psize-1);
  945.      if tab[i].lev < level then emit2(3, tab[i].lev, level)
  946.    end  { call } ;
  947.  
  948. function resulttype(a,b: types): types;
  949. begin
  950.   if (a>reals) or (b>reals) then
  951.     begin error(33); resulttype := notyp
  952.     end else
  953.   if (a=notyp) or (b=notyp) then resulttype := notyp else
  954.   if a = ints then
  955.     if b=ints then resulttype := ints else
  956.       begin resulttype := reals; emit1(26,1)
  957.       end
  958.   else
  959.     begin resulttype := reals;
  960.       if b=ints then emit1(26,0)
  961.     end
  962. end  { resulttype } ;
  963.  
  964. procedure expression;
  965.   var y:item; op:symbol;
  966.  
  967. procedure simpleexpression(fsys:symset; var x:item);
  968.   var y:item; op:symbol;
  969.  
  970. procedure term(fsys:symset; var x:item);
  971.   var y:item; op:symbol; ts:typset;
  972.  
  973.   procedure factor(fsys:symset; var x:item);
  974.     var i,f: integer;
  975.  
  976.               procedure standfct(n: integer);
  977.                  var ts: typset;
  978.               begin  { standard function no. n }
  979.                 if sy = lparent then insymbol else error(9);
  980.                 if n < 17 then
  981.                   begin expression(fsys+[rparent],x);
  982.                     case n of
  983. { abs,sqr }      0,2:  begin ts := [ints,reals];
  984.                          tab[i].typ := x.typ;
  985.                          if x.typ = reals then n := n+1
  986.                        end ;
  987. { odd,chr }      4,5:  ts := [ints];
  988. { ord }          6:    ts := [ints,bools,chars];
  989. { succ,pred }    7,8:  ts := [chars];
  990. { round,trunc }  9,10,11,12,13,14,15,16:
  991.                        begin ts := [ints,reals];
  992.                          if x.typ = ints then emit1(26,0)
  993.                        end ;
  994.                     end ;
  995.                     if x.typ in ts then emit1(8,n) else
  996.                     if x.typ <> notyp then error(48);
  997.                   end else
  998. { eof,eoln }      begin  { n in [17,18] }
  999.                     if sy <> ident then error(2) else
  1000.                   if id <> 'input     ' then error(0) else insymbol;
  1001.  
  1002.                     emit1(8,n);
  1003.                   end ;
  1004.                 x.typ := tab[i].typ;
  1005.                 if sy = rparent then insymbol else error(4)
  1006.               end  { standfct } ;
  1007.  
  1008.             begin { factor } x.typ := notyp; x.ref := 0;
  1009.               test(facbegsys, fsys, 58);
  1010.               while sy in facbegsys do
  1011.                 begin
  1012.                   if sy = ident then
  1013.                   begin i := loc(id); insymbol;
  1014.                     with tab[i] do
  1015.                     case obj of
  1016.               konstant: begin x.typ := typ; x.ref := 0;
  1017.                           if x.typ = reals then
  1018.                             emit1(25,adr) else
  1019.                             emit1(24,adr)
  1020.                         end ;
  1021.               variable: begin x.typ := typ; x.ref := ref;
  1022.                           if sy in [lbrack,lparent,period] then
  1023.                             begin if normal then f := 0 else f := 1;
  1024.                               emit2(f, lev, adr);
  1025.                               selector(fsys,x);
  1026.                               if x.typ in stantyps then emit(34)
  1027.                             end else
  1028.                             begin
  1029.                               if x.typ in stantyps then
  1030.                                 if normal then f := 1 else f := 2
  1031.                               else
  1032.                                 if normal then f := 0 else f := 1;
  1033.                               emit2(f, lev, adr)
  1034.                             end
  1035.                         end ;
  1036.               type1, prozedure:    error(44);
  1037.               funktion :begin x.typ := typ;
  1038.                           if lev <> 0 then call(fsys, i)
  1039.                                 else standfct(adr)
  1040.                         end
  1041.                     end  { case,with }
  1042.                   end else
  1043.                   if sy in [charcon,intcon,realcon] then
  1044.                    begin
  1045.                      if sy = realcon then
  1046.                      begin x.typ := reals; enterreal(rnum);
  1047.                        emit1(25, c1)
  1048.                      end else
  1049.                      begin if sy = charcon then x.typ := chars
  1050.                                            else x.typ := ints;
  1051.                        emit1(24, inum)
  1052.                      end ;
  1053.                      x.ref := 0; insymbol
  1054.                    end else
  1055.                   if sy = lparent then
  1056.                    begin insymbol; expression(fsys+[rparent], x);
  1057.                      if sy = rparent then insymbol else error(4)
  1058.                    end else
  1059.                   if sy = notsy then
  1060.                    begin insymbol; factor(fsys,x);
  1061.                      if x.typ=bools then emit(35) else
  1062.                        if x.typ<>notyp then error(32)
  1063.                    end ;
  1064.                   test(fsys, facbegsys, 6)
  1065.                 end  { while }
  1066.             end  { factor } ;
  1067.           begin  { term }
  1068.             factor(fsys+[times,rdiv,idiv,imod,andsy], x);
  1069.             while sy in [times,rdiv,idiv,imod,andsy] do
  1070.               begin op := sy; insymbol;
  1071.                 factor(fsys+[times,rdiv,idiv,imod,andsy], y);
  1072.                 if op = times then
  1073.                 begin x.typ := resulttype(x.typ, y.typ);
  1074.                 case x.typ of
  1075.                   notyp: ;
  1076.                   ints : emit(57);
  1077.                   reals: emit(60)
  1078.                 end
  1079.               end else
  1080.               if op = rdiv then
  1081.               begin
  1082.                 if x.typ = ints then
  1083.                   begin emit1(26,1); x.typ := reals
  1084.                   end ;
  1085.                 if y.typ = ints then
  1086.                   begin emit1(26,0); y.typ := reals
  1087.                   end ;
  1088.                 if (x.typ=reals) and (y.typ=reals) then
  1089.                   emit(61) else
  1090.                   begin if (x.typ<>notyp) and (y.typ<>notyp) then
  1091.                           error(33);
  1092.                         x.typ := notyp
  1093.                   end
  1094.               end else
  1095.               if op = andsy then
  1096.               begin if (x.typ=bools) and (y.typ=bools) then
  1097.                        emit(56) else
  1098.                     begin if (x.typ<>notyp) and (y.typ<>notyp)
  1099.                         then error(32);
  1100.                        x.typ := notyp
  1101.                     end
  1102.               end else
  1103.               begin { op in [idiv,imod] }
  1104.                 if (x.typ=ints) and (y.typ=ints) then
  1105.                   if op=idiv then emit(58)
  1106.                              else emit(59) else
  1107.                   begin if (x.typ<>notyp) and (y.typ<>notyp) then
  1108.                            error(34);
  1109.                         x.typ := notyp
  1110.                   end
  1111.               end
  1112.             end
  1113.         end { term } ;
  1114.       begin { simpleexpression }
  1115.         if sy in [plus,minus] then
  1116.           begin op := sy; insymbol;
  1117.             term(fsys+[plus,minus], x);
  1118.             if x.typ > reals then error(33) else
  1119.               if op = minus then emit(36)
  1120.           end else
  1121.         term(fsys+[plus,minus,orsy], x);
  1122.         while sy in [plus,minus,orsy] do
  1123.           begin op := sy; insymbol;
  1124.              term(fsys+[plus,minus,orsy], y);
  1125.              if op = orsy then
  1126.              begin
  1127.              if (x.typ=bools) and (y.typ=bools) then emit(51) else
  1128.                  begin if (x.typ<>notyp) and (y.typ<>notyp) then
  1129.                           error(32);
  1130.                        x.typ := notyp
  1131.                  end
  1132.              end else
  1133.              begin x.typ := resulttype(x.typ, y.typ);
  1134.                case x.typ of
  1135.                  notyp: ;
  1136.                  ints : if op = plus then emit(52)
  1137.                                  else emit(53);
  1138.                  reals: if op = plus then emit(54)
  1139.                                  else emit(55)
  1140.                end
  1141.              end
  1142.           end
  1143.       end { simpleexpression } ;
  1144.     begin { expression }
  1145.       simpleexpression(fsys+[eql,neq,lss,leq,gtr,geq], x);
  1146.       if sy in [eql,neq,lss,leq,gtr,geq] then
  1147.         begin op := sy; insymbol;
  1148.            simpleexpression(fsys, y);
  1149.            if (x.typ in [ notyp,ints,bools,chars]) and
  1150.               (x.typ = y.typ) then
  1151.              case op of
  1152.                eql: emit(45);
  1153.                neq: emit(46);
  1154.                lss: emit(47);
  1155.                leq: emit(48);
  1156.                gtr: emit(49);
  1157.                geq: emit(50);
  1158.              end else
  1159.            begin if x.typ = ints then
  1160.                    begin x.typ := reals; emit1(26,1)
  1161.                    end else
  1162.                  if y.typ = ints then
  1163.                    begin y.typ := reals; emit1(26,0)
  1164.                    end ;
  1165.              if (x.typ=reals) and (y.typ=reals) then
  1166.                case op of
  1167.                  eql: emit(39);
  1168.                  neq: emit(40);
  1169.                  lss: emit(41);
  1170.                  leq: emit(42);
  1171.                  gtr: emit(43);
  1172.                  geq: emit(44);
  1173.                end
  1174.              else error(35)
  1175.            end ;
  1176.            x.typ := bools
  1177.         end
  1178.     end { expression } ;
  1179.  
  1180. procedure assignment(lv,ad: integer);
  1181.    var x,y: item; f: integer;
  1182.    { tab[i].obj in [variable,prozedure] }
  1183. begin x.typ := tab[i].typ; x.ref := tab[i].ref;
  1184.   if tab[i].normal then f := 0 else f := 1;
  1185.   emit2(f, lv, ad);
  1186.   if sy in [lbrack,lparent,period] then
  1187.      selector([becomes,eql]+fsys, x);
  1188.   if sy = becomes then insymbol else
  1189.     begin error(51); if sy = eql then insymbol
  1190.     end ;
  1191.   expression(fsys, y);
  1192.   if x.typ = y.typ then
  1193.     if x.typ in stantyps then emit(38) else
  1194.     if x.ref <> y.ref then error(46) else
  1195.     if x.typ = arrays then emit1(23, atab[x.ref].size)
  1196.                       else emit1(23, btab[x.ref].vsize)
  1197.   else
  1198.   if (x.typ=reals) and (y.typ=ints) then
  1199.     begin emit1(26,0); emit(38)
  1200.     end else
  1201.     if (x.typ<>notyp) and (y.typ<>notyp) then error(46)
  1202. end { assignment } ;
  1203.  
  1204. procedure compoundstatement;
  1205. begin insymbol;
  1206.   statement([semicolon,endsy]+fsys);
  1207.   while sy in [semicolon]+statbegsys do
  1208.   begin if sy = semicolon then insymbol else error(14);
  1209.     statement([semicolon,endsy]+fsys)
  1210.   end ;
  1211.   if sy = endsy then insymbol else error(57)
  1212. end  { compoundstatement } ;
  1213.  
  1214. procedure ifstatement;
  1215.    var x: item; lc1,lc2: integer;
  1216. begin insymbol;
  1217.   expression(fsys+[thensy,dosy], x);
  1218.   if not (x.typ in [bools,notyp]) then error(17);
  1219.   lc1 := lc; emit(11); { jmpc }
  1220.   if sy = thensy then insymbol else
  1221.     begin error(52); if sy = dosy then insymbol
  1222.     end ;
  1223.   statement(fsys+[elsesy]);
  1224.   if sy = elsesy then
  1225.     begin insymbol; lc2 := lc; emit(10);
  1226.       code[lc1].y := lc; statement(fsys); code[lc2].y := lc
  1227.     end
  1228.   else code[lc1].y := lc
  1229. end { ifstatement } ;
  1230.  
  1231. procedure casestatement;
  1232.   var x: item;
  1233.     i,j,k,lc1: integer;
  1234.     casetab: array [1..csmax] of
  1235.                packed record val, lc: index end;
  1236.     exittab: array [1..csmax] of integer;
  1237.  
  1238. procedure caselabel;
  1239.   var lab: conrec; k: integer;
  1240. begin constant(fsys+[comma,colon], lab);
  1241.   if lab.tp <> x.typ then error(47) else
  1242.   if i = csmax then fatal(6) else
  1243.     begin i := i+1; k := 0;
  1244.       casetab[i].val := lab.i; casetab[i].lc := lc;
  1245.       repeat k := k+1 until casetab[k].val = lab.i;
  1246.       if k < 1 then error(1);  { multiple definition }
  1247.     end
  1248. end { caselabel } ;
  1249.  
  1250. procedure onecase;
  1251. begin if sy in constbegsys then
  1252.   begin caselabel;
  1253.     while sy = comma do
  1254.       begin insymbol; caselabel
  1255.       end ;
  1256.     if sy = colon then insymbol else error(5);
  1257.     statement([semicolon,endsy]+fsys);
  1258.     j := j+1; exittab[j] := lc; emit(10)
  1259.   end
  1260. end  { onecase } ;
  1261.  
  1262. begin insymbol; i := 0; j := 0;
  1263.   expression(fsys+[ofsy,comma,colon], x);
  1264.   if not (x.typ in [ints,bools,chars,notyp]) then error(23);
  1265.   lc1 := lc; emit(12); { jmpx }
  1266.   if sy = ofsy then insymbol else error(8);
  1267.   onecase;
  1268.   while sy = semicolon do
  1269.     begin insymbol; onecase
  1270.     end ;
  1271.   code[lc1].y := lc;
  1272.   for k := 1 to 1 do
  1273.     begin emit1(13,casetab[k].val); emit1(13,casetab[k].lc)
  1274.     end ;
  1275.   emit1(10,0);
  1276.   for k := 1 to j do code[exittab[k]].y := lc;
  1277.   if sy = endsy then insymbol else error(57)
  1278. end  { casestatement } ;
  1279.  
  1280. procedure repeatstatement;
  1281.    var x: item; lc1: integer;
  1282. begin lc1 := lc;
  1283.   insymbol; statement([semicolon,untilsy]+fsys);
  1284.   while sy in [semicolon]+statbegsys do
  1285.   begin if sy = semicolon then insymbol else error(14);
  1286.     statement([semicolon,untilsy]+fsys)
  1287.   end ;
  1288.   if sy = untilsy then
  1289.     begin insymbol; expression(fsys, x);
  1290.       if not (x.typ in [bools,notyp]) then error(17);
  1291.       emit1(11,lc1)
  1292.     end
  1293.   else error(53)
  1294. end { repeatstatement } ;
  1295.  
  1296. procedure whilestatement;
  1297.    var x: item; lc1,lc2: integer;
  1298. begin insymbol; lc1 := lc;
  1299.   expression(fsys+[dosy], x);
  1300.   if not (x.typ in [bools,notyp]) then error(17);
  1301.   lc2 := lc; emit(11);
  1302.   if sy = dosy then insymbol else error(54);
  1303.   statement(fsys); emit1(10,lc1); code[lc2].y := lc
  1304. end { whilestatement } ;
  1305.  
  1306. procedure forstatement;
  1307.    var cvt: types; x: item;
  1308.        i,f,lc1,lc2: integer;
  1309. begin insymbol;
  1310.   if sy = ident then
  1311.     begin i := loc(id); insymbol;
  1312.       if i = 0 then cvt := ints else
  1313.       if tab[i].obj = variable then
  1314.         begin cvt := tab[i].typ;
  1315.           emit2(0, tab[i].lev, tab[i].adr);
  1316.           if not (cvt in [notyp,ints,bools,chars])
  1317.              then error(18)
  1318.         end else
  1319.         begin error(37); cvt := ints
  1320.         end
  1321.     end else skip([becomes,tosy,downtosy,dosy]+fsys, 2);
  1322.   if sy = becomes then
  1323.     begin insymbol; expression([tosy,downtosy,dosy]+fsys, x);
  1324.       if x.typ <> cvt then error(19);
  1325.     end else skip([tosy,downtosy,dosy]+fsys, 51);
  1326.   f := 14;
  1327.   if sy in [tosy, downtosy] then
  1328.     begin if sy = downtosy then f := 16;
  1329.       insymbol; expression([dosy]+fsys, x);
  1330.       if x.typ <> cvt then error(19)
  1331.     end else skip([dosy]+fsys, 55);
  1332.   lc1 := lc; emit(f);
  1333.   if sy = dosy then insymbol else error(54);
  1334.   lc2 := lc; statement(fsys);
  1335.   emit1(f+1,lc2); code[lc1].y := lc
  1336. end { forstatement } ;
  1337.  
  1338.     procedure standproc(n: integer);
  1339.        var i,f: integer;
  1340.            x,y: item;
  1341.     begin
  1342.       case n of
  1343. 1,2:  begin { read }
  1344.         if sy = lparent then
  1345.         begin
  1346.           repeat insymbol;
  1347.             if sy <> ident then error(2) else
  1348.             begin i := loc(id); insymbol;
  1349.               if i <> 0 then
  1350.               if tab[i].obj <> variable then error(37) else
  1351.               begin x.typ := tab[i].typ; x.ref := tab[i].ref;
  1352.                 if tab[i].normal then f := 0 else f := 1;
  1353.                 emit2(f, tab[i].lev, tab[i].adr);
  1354.                 if sy in [lbrack,lparent,period] then
  1355.                   selector(fsys+[comma,rparent], x);
  1356.                 if x.typ in [ints,reals,chars,notyp] then
  1357.                   emit1(27, ord(x.typ)) else error(40)
  1358.               end
  1359.             end ;
  1360.             test([comma,rparent], fsys, 6);
  1361.           until sy <> comma;
  1362.           if sy = rparent then insymbol else error(4)
  1363.         end ;
  1364.         if n = 2 then emit(62)
  1365.       end ;
  1366.  3,4: begin { write }
  1367.         if sy = lparent then
  1368.         begin
  1369.           repeat insymbol;
  1370.             if sy = string then
  1371.               begin emit1(24,sleng); emit1(28,inum); insymbol
  1372.               end else
  1373.             begin expression(fsys+[comma,colon,rparent], x);
  1374.               if not (x.typ in stantyps) then error(41);
  1375.               if sy = colon then
  1376.               begin insymbol;
  1377.                 expression(fsys+[comma,colon,rparent], y);
  1378.                 if y.typ <> ints then error(43);
  1379.                 if sy = colon then
  1380.                 begin if x.typ <> reals then error(42);
  1381.                   insymbol; expression(fsys+[comma,rparent], y);
  1382.                   if y.typ <> ints then error(43);
  1383.                   emit(37)
  1384.                 end
  1385.                 else emit1(30, ord(x.typ))
  1386.               end
  1387.               else emit1(29, ord(x.typ))
  1388.             end
  1389.         until sy <> comma;
  1390.         if sy = rparent then insymbol else error(4)
  1391.       end ;
  1392.       if n = 4 then emit(63)
  1393.     end ;
  1394.     end { case }
  1395.   end { standproc } ;
  1396.  
  1397. begin { statement }
  1398.   if sy in statbegsys+[ident] then
  1399.       case sy of
  1400.         ident:    begin i := loc(id); insymbol;
  1401.                     if i <> 0 then
  1402.                     case tab[i].obj of
  1403.                       konstant, type1: error(45);
  1404.                       variable:
  1405.                           assignment(tab[i].lev, tab[i].adr);
  1406.                       prozedure:
  1407.                         if tab[i].lev <> 0 then call(fsys, i)
  1408.                                 else standproc(tab[i].adr);
  1409.                       funktion:
  1410.                         if tab[i].ref = display[level]
  1411.                           then assignment(tab[i].lev+1,0)
  1412.                           else error(45)
  1413.                     end
  1414.                   end ;
  1415.         beginsy:  compoundstatement;
  1416.         ifsy:     ifstatement;
  1417.         casesy:   casestatement;
  1418.         whilesy:  whilestatement;
  1419.         repeatsy: repeatstatement;
  1420.         forsy:    forstatement;
  1421.       end;
  1422.     test(fsys, [], 14)
  1423.   end  { statement } ;
  1424.  
  1425. begin { block }
  1426.   dx := 5; prt := t;
  1427.   if level > lmax then fatal(5);
  1428.   test([lparent,colon,semicolon], fsys, 7);
  1429.   enterblock; display[level] := b; prb := b;
  1430.   tab[prt].typ := notyp; tab[prt].ref := prb;
  1431.   if sy = lparent then parameterlist;
  1432.   btab[prb].lastpar := t; btab[prb].psize := dx;
  1433.   if isfun then
  1434.     if sy = colon then
  1435.     begin insymbol;  { function type }
  1436.       if sy = ident then
  1437.       begin x:= loc(id); insymbol;
  1438.         if x <> 0 then
  1439.           if tab[x].obj <> type1 then error(29) else
  1440.             if tab[x].typ in stantyps
  1441.               then tab[prt].typ := tab[x].typ
  1442.               else error(15)
  1443.       end else skip([semicolon]+fsys, 2)
  1444.     end else error(5);
  1445.   if sy = semicolon then insymbol else error(14);
  1446.   repeat
  1447.     if sy = constsy then constantdeclaration;
  1448.     if sy = typesy then typedeclaration;
  1449.     if sy = varsy then variabledeclaration;
  1450.     btab[prb].vsize := dx;
  1451.     while sy in [proceduresy,functionsy] do procdeclaration;
  1452.     test([beginsy], blockbegsys+statbegsys, 56)
  1453.   until sy in statbegsys;
  1454.   tab[prt].adr := lc;
  1455.   insymbol; statement([semicolon,endsy]+fsys);
  1456.   while sy in [semicolon]+statbegsys do
  1457.     begin if sy = semicolon then insymbol else error(14);
  1458.       statement([semicolon,endsy]+fsys)
  1459.     end ;
  1460.   if sy = endsy then insymbol else error(57);
  1461.   test(fsys+[period], [], 6)
  1462. end { block } ;
  1463.  
  1464.  
  1465. procedure interpret;
  1466.    { global code, tab, btab }
  1467.    var ir: order;      { instruction buffer }
  1468.        pc: integer;    { program counter }
  1469.        ps: (run,fin,caschk,divchk,inxchk,stkchk,linchk,
  1470.             lngchk,redchk);
  1471.        t:  integer;    { top stack index }
  1472.        b:  integer;    { base index }
  1473.        lncnt, ocnt, blkcnt, chrcnt: integer;   { counters }
  1474.        h1,h2,h3,h4: integer;
  1475.        fld: array [1..4] of integer;    { default field widths }
  1476.        step, sdump: boolean;
  1477.        display: array [1..lmax] of integer;
  1478.        s: array [1..stacksize] of    { blockmark:               }
  1479.           record case types of       {    s[b+0] = fct result   }
  1480.             ints:  (i: integer);     {    s[b+1] = return adr   }
  1481.             reals: (r: real);        {    s[b+2] = static link  }
  1482.             bools: (b: boolean);     {    s[b+3] = dynamic link }
  1483.             chars: (c: char)         {    s[b+4] = table index  }
  1484.           end ;
  1485.        j: integer;
  1486.        ch: char;
  1487.  
  1488.   procedure initialise;
  1489.   var j: integer;
  1490.   begin
  1491.      writeln;
  1492.      writeln('Executing Pascal-S program:   ', progname);
  1493.      write('Do you want a step-by-step execution? ');
  1494.      readln(ch); step := ch in ['y','Y'];
  1495.      write('Do you want a stackdump? ');
  1496.      readln(ch); sdump := ch in ['y','Y'];
  1497.      writeln;
  1498.      lncnt := 0; ocnt := 0; chrcnt := 0;
  1499.      fld[1] := 10; fld[2] := 22; fld[3] := 10; fld[4] := 1;
  1500.  {   for j := 1 to 6 do display[j] := 9999;  *to avoid r/t error}
  1501.  {   for j := 1 to 6 do s[j].i := 9999;         *to avoid r/t error}
  1502.   end;
  1503.  
  1504.   procedure runtimedump;
  1505.   var j: integer;
  1506.   begin
  1507.      writeln('******** stack dump ********');
  1508.      writeln(' t = ', t:3);
  1509.      for j := 1 to t do with s[j] do
  1510.      begin  write(j:3,': ',i:10,'    '); if (j mod 4) = 0 then writeln end;
  1511.      if (t mod 4) <> 0 then writeln;
  1512.       {writeln(j,':   ',i,'***',r,'***',b,'***',c);}
  1513.      writeln('+++++++ display dump +++++++');
  1514.      for j := 1 to 4 do write(j:3,': ', display[j]:10, '    ');
  1515.      writeln;
  1516.      for j := 5 to 7 do write(j:3,': ', display[j]:10, '    ');
  1517.      writeln;
  1518.      writeln('****************************');
  1519.   end; { runtimedump }
  1520.  
  1521.   procedure postmortem;    {post mortem dump}
  1522.   begin
  1523.     writeln;
  1524.     write('halt at', pc:5, ' because of ');
  1525.     case ps of
  1526.       caschk: writeln('undefined case');
  1527.       divchk: writeln('division by 0');
  1528.       inxchk: writeln('invalid index');
  1529.       stkchk: writeln('storage overflow');
  1530.       linchk: writeln('too much output');
  1531.       lngchk: writeln('line too long');
  1532.       redchk: writeln('reading past end of file');
  1533.     end ;
  1534.     h1 := b; blkcnt := 10;   { post mortem dump }
  1535.     repeat writeln; blkcnt := blkcnt - 1;
  1536.       if blkcnt = 0 then h1 := 0; h2 := s[h1+4].i;
  1537.       if h1<>0 then
  1538.         writeln(' ', tab[h2].name, ' called at', s[h1+1].i: 5);
  1539.       h2 := btab[tab[h2].ref].last;
  1540.       while h2 <> 0 do
  1541.       with tab[h2] do
  1542.       begin if obj = variable then
  1543.             if typ in stantyps then
  1544.             begin write('    ', name, ' = ');
  1545.               if normal then h3 := h1+adr else h3 := s[h1+adr].i;
  1546.               case typ of
  1547.                ints:  writeln(s[h3].i);
  1548.                reals: writeln(s[h3].r);
  1549.                bools: writeln(s[h3].b);
  1550.                chars: writeln(s[h3].c);
  1551.               end
  1552.             end ;
  1553.             h2 := link
  1554.       end ;
  1555.       h1 := s[h1+3].i
  1556.     until h1 < 0;
  1557.   end; {postmortem}
  1558.  
  1559. begin { interpret }
  1560.   initialise;
  1561.   b := 0;  t := btab[2].vsize - 1;
  1562.   s[1].i := 0; s[2].i := 0; s[3].i := -1;  s[4].i := btab[1].last;
  1563.   {b+1:return addr; b+2:static link; b+3:dynamic link; b+4:table index}
  1564.   display[1] := 0;
  1565.   pc := tab[s[4].i].adr;  ps := run;
  1566.   if sdump then runtimedump;
  1567.   repeat
  1568.     ir := code[pc];  ocnt := ocnt + 1;
  1569.     if step then with ir do
  1570.     begin write('step',ocnt:5, '    pc = ', pc:5, f:10, '       ');
  1571.           if f < 31 then
  1572.             if f < 4 then write(x:2, ' ', y:5)
  1573.                      else write(y:8);
  1574.           writeln;
  1575.     end;
  1576.     if sdump then runtimedump;
  1577.     pc := pc+1;
  1578.     case ir.f of
  1579.         0: begin  { load address } t := t+1;
  1580.              if t > stacksize then ps := stkchk
  1581.                else s[t].i := display[ir.x] + ir.y
  1582.            end ;
  1583.         1: begin { load value } t := t+1;
  1584.              if t > stacksize then ps := stkchk
  1585.               else s[t] := s[display[ir.x] + ir.y]
  1586.            end ;
  1587.         2: begin { load indirect } t := t+1;
  1588.              if t > stacksize then ps := stkchk
  1589.                else s[t] := s[s[display[ir.x] + ir.y].i]
  1590.            end ;
  1591.         3: begin { update display }
  1592.              h1 := ir.y; h2 := ir.x; h3 := b;
  1593.              repeat display[h1] := h3; h1 := h1-1; h3 := s[h3+2].i
  1594.              until h1 = h2
  1595.            end ;
  1596.         8: case ir.y of
  1597.             0: s[t].i := abs(s[t].i);
  1598.             1: s[t].r := abs(s[t].r);
  1599.             2: s[t].i := sqr(s[t].i);
  1600.             3: s[t].r := sqr(s[t].r);
  1601.             4: s[t].b := odd(s[t].i);
  1602.             5: begin { s[t].c := chr(s[t].i); }
  1603.                  if (s[t].i < 0) or (s[t].i > 63) then ps := inxchk
  1604.                end ;
  1605.             6: { s[t].i := ord(s[t].c) - chars are stored as ordinal nos};
  1606.             7: s[t].c := succ(s[t].c);
  1607.             8: s[t].c := pred(s[t].c);
  1608.             9: s[t].i := round(s[t].r);
  1609.            10: s[t].i := trunc(s[t].r);
  1610.            11: s[t].r := sin(s[t].r);
  1611.            12: s[t].r := cos(s[t].r);
  1612.            13: s[t].r := exp(s[t].r);
  1613.            14: s[t].r := ln(s[t].r);
  1614.            15: s[t].r := sqrt(s[t].r);
  1615.            16: s[t].r := arctan(s[t].r);
  1616.            17: begin t := t+1;
  1617.                  if t > stacksize then ps := stkchk
  1618.                                   else s[t].b := eof(input)
  1619.                end ;
  1620.            18: begin t := t+1;
  1621.                  if t > stacksize then ps := stkchk
  1622.                                   else s[t].b := eoln(input)
  1623.                end ;
  1624.            end ;
  1625.         9: s[t].i := s[t].i + ir.y;   { offset }
  1626.        10: pc := ir.y;  { jump }
  1627.        11: begin  { conditional jump }
  1628.              if not s[t].b then pc := ir.y;  t := t-1
  1629.            end ;
  1630.        12: begin { switch } h1 := s[t].i; t := t-1;
  1631.              h2 := ir.y; h3 := 0;
  1632.              repeat if code[h2].f <> 13 then
  1633.                       begin h3 := 1; ps := caschk
  1634.                       end else
  1635.                     if code[h2].y = h1 then
  1636.                       begin h3 := 1; pc := code[h2+1].y
  1637.                       end else
  1638.                     h2 := h2 + 2
  1639.              until h3 <> 0
  1640.            end ;
  1641.        14: begin { for1up } h1 := s[t-1].i;
  1642.              if h1 <= s[t].i then s[s[t-2].i].i := h1 else
  1643.                 begin t := t-3; pc := ir.y
  1644.                 end
  1645.            end ;
  1646.        15: begin { for2up } h2 := s[t-2].i; h1 := s[h2].i + 1;
  1647.              if h1 <= s[t].i then
  1648.                begin s[h2].i := h1; pc := ir.y end
  1649.              else t := t-3;
  1650.            end ;
  1651.        16: begin { for1down } h1 := s[t-1].i;
  1652.              if h1 >= s[t].i then s[s[t-2].i].i := h1 else
  1653.                 begin pc := ir.y; t := t-3
  1654.                 end
  1655.            end ;
  1656.        17: begin { for2down } h2 := s[t-2].i; h1 := s[h2].i - 1;
  1657.              if h1 >= s[t].i then
  1658.                begin s[h2].i := h1; pc := ir.y end
  1659.              else t := t-3;
  1660.            end ;
  1661.        18: begin { mark stack }   h1 := btab[tab[ir.y].ref].vsize;
  1662.              if t+h1 > stacksize then ps := stkchk else
  1663.                begin t := t+5; s[t-1].i := h1-1; s[t].i := ir.y
  1664.                end
  1665.            end ;
  1666.        19: begin { call } h1 := t - ir.y;  { h1 points to base }
  1667.              h2 := s[h1+4].i;              { h2 points to tab }
  1668.              h3 := tab[h2].lev; display[h3+1] := h1;
  1669.              h4 := s[h1+3].i + h1;
  1670.              s[h1+1].i := pc; s[h1+2].i := display[h3]; s[h1+3].i := b;
  1671.              for h3 := t+1 to h4 do s[h3].i := 0;
  1672.              b := h1; t := h4; pc := tab[h2].adr
  1673.            end ;
  1674.        20: begin { index1 } h1 := ir.y;    { h1 points to atab }
  1675.              h2 := atab[h1].low; h3 := s[t].i;
  1676.              if h3 < h2 then ps := inxchk else
  1677.              if h3 > atab[h1].high then ps := inxchk else
  1678.                begin t := t-1; s[t].i := s[t].i + (h3-h2)
  1679.                end
  1680.            end ;
  1681.        21: begin { index }  h1 := ir.y;    { h1 points to atab }
  1682.              h2 := atab[h1].low; h3 := s[t].i;
  1683.              if h3 < h2 then ps := inxchk else
  1684.              if h3 > atab[h1].high then ps := inxchk else
  1685.                begin t := t-1; s[t].i := s[t].i + (h3-h2)*atab[h1].elsize
  1686.                end
  1687.            end ;
  1688.        22: begin { load block } h1 := s[t].i; t := t-1;
  1689.              h2 := ir.y + t; if h2 > stacksize then ps := stkchk else
  1690.              while t < h2 do
  1691.                begin t := t+1; s[t] := s[h1]; h1 := h1+1
  1692.                end
  1693.            end ;
  1694.        23: begin { copy block } h1 := s[t-1].i;
  1695.              h2 := s[t].i; h3 := h1 + ir.y;
  1696.              while h1 < h3 do
  1697.                begin s[h1] := s[h2]; h1 := h1+1; h2 := h2+1
  1698.                end ;
  1699.              t := t-2
  1700.            end ;
  1701.        24: begin { literal } t := t+1;
  1702.              if t > stacksize then ps := stkchk else s[t].i := ir.y
  1703.            end ;
  1704.        25: begin { load real } t := t+1;
  1705.              if t>stacksize then ps := stkchk else s[t].r := rconst[ir.y]
  1706.            end ;
  1707.        26: begin { float } h1 := t - ir.y; s[h1].r := s[h1].i
  1708.            end ;
  1709.        27: begin { read }
  1710.              if eof(input) then ps := redchk else
  1711.                 case ir.y of
  1712.                  1: read(input,s[s[t].i].i);
  1713.                  2: read(input,s[s[t].i].r);
  1714.                  4: begin read(input,ch); s[s[t].i].i := ord(ch) end;
  1715.                 end ;
  1716.              t := t-1
  1717.            end ;
  1718.        28: begin { write string }
  1719.              h1 := s[t].i; h2 := ir.y; t := t-1;
  1720.              chrcnt := chrcnt+h1; if chrcnt > lineleng then ps := lngchk;
  1721.              repeat write(stab[h2]); h1 := h1-1; h2 := h2+1
  1722.              until h1 = 0
  1723.            end ;
  1724.        29: begin { write1 }
  1725.              chrcnt := chrcnt + fld[ir.y];
  1726.              if chrcnt > lineleng then ps := lngchk else
  1727.              case ir.y of
  1728.               1: write(s[t].i: fld[1]);
  1729.               2: write(s[t].r: fld[2]);
  1730.               3: write(s[t].b: fld[3]);
  1731.               4: write(chr(s[t].i));
  1732.              end ;
  1733.              t := t-1
  1734.            end ;
  1735.        30: begin { write2 }
  1736.              chrcnt := chrcnt + s[t].i;
  1737.              if chrcnt > lineleng then ps := lngchk else
  1738.              case ir.y of
  1739.               1: write(s[t-1].i: s[t].i);
  1740.               2: write(s[t-1].r: s[t].i);
  1741.               3: write(s[t-1].b: s[t].i);
  1742.               4: write(s[t-1].c: s[t].i);
  1743.              end ;
  1744.              t := t-2
  1745.            end ;
  1746.        31: ps := fin;
  1747.        32: begin { exit procedure }
  1748.              t := b-1; pc := s[b+1].i; b := s[b+3].i
  1749.            end ;
  1750.        33: begin { exit function }
  1751.              t := b; pc := s[b+1].i; b := s[b+3].i
  1752.            end ;
  1753.        34: s[t] := s[s[t].i];
  1754.        35: s[t].b := not s[t].b;
  1755.        36: s[t].i := - s[t].i;
  1756.        37: begin chrcnt := chrcnt + s[t-1].i;
  1757.              if chrcnt > lineleng then ps := lngchk else
  1758.                 write(s[t-2].r: s[t-1].i: s[t].i);
  1759.              t := t-3
  1760.            end ;
  1761.        38: begin { store } s[s[t-1].i] := s[t]; t := t-2
  1762.            end ;
  1763.        39: begin t := t-1; s[t].b := s[t].r = s[t+1].r
  1764.            end ;
  1765.        40: begin t := t-1; s[t].b := s[t].r <> s[t+1].r
  1766.            end ;
  1767.        41: begin t := t-1; s[t].b := s[t].r < s[t+1].r
  1768.            end ;
  1769.        42: begin t := t-1; s[t].b := s[t].r <= s[t+1].r
  1770.            end ;
  1771.        43: begin t := t-1; s[t].b := s[t].r > s[t+1].r
  1772.            end ;
  1773.        44: begin t := t-1; s[t].b := s[t].r >= s[t+1].r
  1774.            end ;
  1775.        45: begin t := t-1; s[t].b := s[t].i = s[t+1].i
  1776.            end ;
  1777.        46: begin t := t-1; s[t].b := s[t].i <> s[t+1].i
  1778.            end ;
  1779.        47: begin t := t-1; s[t].b := s[t].i < s[t+1].i
  1780.            end ;
  1781.        48: begin t := t-1; s[t].b := s[t].i <= s[t+1].i
  1782.            end ;
  1783.        49: begin t := t-1; s[t].b := s[t].i > s[t+1].i
  1784.            end ;
  1785.        50: begin t := t-1; s[t].b := s[t].i >= s[t+1].i
  1786.            end ;
  1787.        51: begin t := t-1; s[t].b := s[t].b or s[t+1].b
  1788.            end ;
  1789.        52: begin t := t-1; s[t].i := s[t].i + s[t+1].i
  1790.            end ;
  1791.        53: begin t := t-1; s[t].i := s[t].i - s[t+1].i
  1792.            end ;
  1793.        54: begin t := t-1; s[t].r := s[t].r + s[t+1].r;
  1794.            end ;
  1795.        55: begin t := t-1; s[t].r := s[t].r - s[t+1].r;
  1796.            end ;
  1797.        56: begin t := t-1; s[t].b := s[t].b and s[t+1].b
  1798.            end ;
  1799.        57: begin t := t-1; s[t].i := s[t].i * s[t+1].i
  1800.            end ;
  1801.        58: begin t := t-1;
  1802.              if s[t+1].i = 0 then ps := divchk else
  1803.                s[t].i := s[t].i div s[t+1].i
  1804.            end ;
  1805.        59: begin t:= t-1;
  1806.              if s[t+1].i = 0 then ps := divchk else
  1807.                s[t].i := s[t].i mod s[t+1].i
  1808.            end ;
  1809.        60: begin t := t-1; s[t].r := s[t].r * s[t+1].r;
  1810.            end ;
  1811.        61: begin t := t-1; s[t].r := s[t].r / s[t+1].r;
  1812.            end ;
  1813.        62: if eof(input) then ps := redchk else readln(input);
  1814.        63: begin writeln; lncnt := lncnt + 1; chrcnt := 0;
  1815.               if lncnt > linelimit then ps := linchk
  1816.            end
  1817.           end { case } ;
  1818.   until ps <> run;
  1819.  
  1820.   if ps <> fin then postmortem;
  1821.   writeln; writeln(ocnt, ' steps')
  1822. end { interpret } ;
  1823.  
  1824. begin   {main program }
  1825.   initialise;  writeln;
  1826.  
  1827.   insymbol;
  1828.   if sy <> programsy then error(3) else
  1829.   begin insymbol;
  1830.     if sy <> ident then error(2) else
  1831.     begin progname := id; insymbol;
  1832.       if sy = lparent then
  1833.       begin
  1834.         repeat insymbol;
  1835.            if sy = ident then
  1836.            begin if (id <> 'input     ')  and (id <> 'output    ')
  1837.                      then error(0);
  1838.                  insymbol
  1839.            end
  1840.         until sy <> comma;
  1841.         if sy = rparent then insymbol else error(4);
  1842.       end
  1843.     end ;
  1844.   end;
  1845.  
  1846.   init_symboltable;  { set up standard identifiers }
  1847.   with btab[1] do
  1848.   begin last := t; lastpar := 1; psize := 0; vsize := 0
  1849.   end ;
  1850.  
  1851.   block(blockbegsys+statbegsys, false, 1);
  1852.   if sy <> period then error(22);
  1853.   emit(31);   { halt }
  1854.   if btab[2].vsize > stacksize then error(49);
  1855.  
  1856.   reset(input, '/dev/tty'); writeln;
  1857.   write('Do you want a listing of tables? ');
  1858.   readln(ch);
  1859.   if ch in ['y','Y'] then
  1860.   begin  printtables;   flush(output) end;
  1861.   if errs = [] then interpret else errormsg;
  1862. 99:
  1863. end.
  1864.  
  1865.